C---------------------------------------------------------
C    TOOLPACK/1    Release: 3.1
C---------------------------------------------------------
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.4
C---------------------------------------------------------
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.4
C---------------------------------------------------------
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.4
C---------------------------------------------------------
 
 
 
 
 
 
 
 
C                                   parameter length
 
 
 
 
 
 
 
 
 
C following are for ZYCSDT (Canonicalise Symbol Data Types)
        PROGRAM ISTGI
 
        INTEGER IODSYI,IODSYO,SYIPTH(81),SYOPTH(81),PROMPT(22,2),
     +          JUNK
 
        INTEGER GETARG,OPEN,CREATE,ZGTCMD
        EXTERNAL GETARG,OPEN,CREATE,ZYINSY,ZGTCMD,ZYSOUT,ZINIT,ZQUIT,
     +           ZMESS,ERROR
 
        DATA (PROMPT(I,1),I=1,21)/73,110,112,117,116,32,115,
     +121,109,98,111,108,32,116,97,98,108,101,58,
     +32,129/,
     +       (PROMPT(I,2),I=1,22)/79,117,116,112,117,116,32,
     +115,121,109,98,111,108,32,116,97,98,108,101,58,
     +32,129/
 
        CALL ZINIT
 
        IF (GETARG(1,SYIPTH,81).EQ.-100) THEN
            CALL ZPRMPT(PROMPT(1,1))
            JUNK=ZGTCMD(SYIPTH,0)
        END IF
        IF (GETARG(2,SYOPTH,81).EQ.-100) THEN
            CALL ZPRMPT(PROMPT(1,2))
            JUNK=ZGTCMD(SYOPTH,0)
        END IF
 
        IODSYI=OPEN(SYIPTH,0)
        IF (IODSYI.EQ.-1) CALL ERROR('Can''t open input symbol table')
        IODSYO=CREATE(SYOPTH,1)
        IF (IODSYO.EQ.-1) CALL ERROR('Can''t create o/p symbol table')
 
        CALL ZYINSY(IODSYI)
 
        CALL PROFIL
 
        CALL ZYSOUT(IODSYO)
        CALL ZMESS('[ISTGI Normal Termination]',1)
        CALL ZQUIT(-2)
 
        END
C ----------------------------------------------------------------------
C
C       P R O F I L   -   Process file
C
 
        SUBROUTINE PROFIL
 
        INTEGER NCONVS
        PARAMETER (NCONVS=44)
 
        INTEGER SYMBOL(8),SYMPTR,BITS,TEXT(134),STRPTR,
     +          N,RESULT(8),IFTYPE(NCONVS),TEXT2(134)
        CHARACTER*6 SYMNAM,IFNAME(2,NCONVS)
        LOGICAL CHANGE
 
        INTEGER ZYGNSY,ZIAND,ZYASTR,ZYFSYM,ZYGPUS
        EXTERNAL ZYGNSY,ZIAND,ZYSATT,ZYASTR,PUTLIN,ZMESS,ZYGTST,ZITOF,
     +           ZFTOI,ZYFSYM,ZSTRIP,ZYGPUS,ZYGTSY
 
        DATA IFNAME/'DSINH','SINH','DCOSH','COSH','DTANH','TANH',
     +'IFIX','INT','IDINT','INT','FLOAT','REAL','SNGL','REAL',
     +'DINT','AINT','DNINT','ANINT','IDNINT','NINT','IABS','ABS',
     +'DABS','ABS','CABS','ABS','AMOD','MOD','DMOD','MOD',
     +'ISIGN','SIGN','DSIGN','SIGN','IDIM','DIM','DDIM','DIM',
     +'MAX0','MAX','AMAX1','MAX','DMAX1','MAX','MIN0','MIN',
     +'AMIN1','MIN','DMIN1','MIN','DSQRT','SQRT','CSQRT','SQRT',
     +'ALOG10','LOG10','DLOG10','LOG10','DEXP','EXP','CEXP','EXP',
     +'ALOG','LOG','DLOG','LOG','CLOG','LOG','DSIN','SIN','CSIN','SIN',
     +'DCOS','COS','CCOS','COS','DTAN','TAN','DASIN','ASIN',
     +'DACOS','ACOS','DATAN','ATAN','DATAN2','ATAN2','CDABS','ABS'/
 
        DATA IFTYPE/3*8,2*1,2*2,
     +2*8,1,34*8/
 
        SYMPTR=0
 
 100    IF (ZYGNSY(SYMPTR,SYMBOL).EQ.-100) RETURN
        BITS=SYMBOL(6)
        IF (SYMBOL(1).EQ.7 .AND.
     +      ZIAND(BITS,4096).NE.0) THEN
            CALL ZYGTST(SYMBOL(2),TEXT)
C
C Change it if it matches one of our list of non-generic functions
C
            CALL ZITOF(TEXT,1,6,SYMNAM,.FALSE.)
            N=0
 200        N=N+1
            IF (N.LT.NCONVS .AND. SYMNAM.NE.IFNAME(1,N)) GOTO 200
            IF (SYMNAM.EQ.IFNAME(1,N)) THEN
C
C Yes - change it unless ...
C
                CALL ZFTOI(IFNAME(2,N),1,6,TEXT2,.FALSE.)
                CALL ZSTRIP(TEXT2)
                CHANGE=.TRUE.
C ... It was explicitly typed
                IF (ZIAND(BITS,8).NE.0) THEN
                    CALL PUTLIN(TEXT,2)
                    CALL ZCHOUT(' n'//
     +                          'ot changed due to explicit typing, in '
     +                        ,2)
                    CALL ZYGTSY(ZYGPUS(SYMBOL(3)),SYMBOL)
                    CALL ZYGTST(SYMBOL(2),TEXT)
                    CALL PUTLIN(TEXT,2)
                    CALL PUTCH(10,2)
                    CHANGE=.FALSE.
C ... or it was used as an actual argument
                ELSE IF (ZIAND(BITS,2048).NE.0) THEN
                    CALL PUTLIN(TEXT,2)
                    CALL ZCHOUT(' used as actual argument - n'//
     +                         'ot changed, in ',2)
                    CALL ZYGTSY(ZYGPUS(SYMBOL(3)),SYMBOL)
                    CALL ZYGTST(SYMBOL(2),TEXT)
                    CALL PUTLIN(TEXT,2)
                    CALL PUTCH(10,2)
                    CHANGE=.FALSE.
C ... or the resultant function name is already used as something else
                ELSE IF (ZYFSYM(TEXT2,SYMBOL(3),RESULT).NE.-1)
     +              THEN
C It is used - if it is not used as an intrinsic give an error
                    IF (RESULT(1).NE.7 .OR.
     +                  ZIAND(RESULT(6),4096).EQ.0
     +                  .OR. RESULT(4).NE.IFTYPE(N)) THEN
                        CALL ZCHOUT('Couldn''t use function ',2)
                        CALL PUTLIN(TEXT2,2)
                        CALL ZMESS(' due to name clash, in ',2)
                        CALL ZYGTSY(ZYGPUS(SYMBOL(3)),SYMBOL)
                        CALL ZYGTST(SYMBOL(2),TEXT)
                        CALL PUTLIN(TEXT,2)
                        CALL PUTCH(10,2)
                        CHANGE=.FALSE.
                    ELSE
                        CALL ZCHOUT('Duplicate symbol "',2)
                        CALL PUTLIN(TEXT2,2)
                        CALL ZMESS('" produced - further analysis'//
     +' must be preceded by YF a'//'nd YP',2)
                    END IF
                END IF
                IF (CHANGE) THEN
                    STRPTR=ZYASTR(TEXT2)
                    CALL ZYSATT(SYMPTR,2,STRPTR)
                    CALL ZYSATT(SYMPTR,4,IFTYPE(N))
                END IF
            END IF
        END IF
        GO TO 100
 
        END
